;;; ext-mouse.el --- support the mouse better when emacs runs in an xterm

;; Copyright (C) 2010 Ryan Johnson

;; This is an extension to xt-mouse.el which improves mouse handling
;; support by making dragging responsive. It depends on read-key,
;; which was introduced in emacs-23, and on the utf-8
;; keyboard-coding-system (which is normally enabled by default in
;; recent versions of emcas)

;; For best results with terminals larger than 95 columns or lines,
;; emacs should run within a patched xterm which sends utf-8-encoded
;; mouse events (see
;; http://www.ece.cmu.edu/~ryanjohn/linux-hacks.html#xterm-mouse-utf-8
;; for details)

;; Copyright (C) 1994, 2000, 2001, 2002, 2003,
;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.

;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: mouse, terminals

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Enable mouse support when running inside an xterm.

;; This is actually useful when you are running X11 locally, but is
;; working on remote machine over a modem line or through a gateway.

;; It works by translating xterm escape codes into generic emacs mouse
;; events so it should work with any package that uses the mouse.

;; You don't have to turn off xterm mode to use the normal xterm mouse
;; functionality, it is still available by holding down the SHIFT key
;; when you press the mouse button.

;;; Todo:

;; Support multi-click -- somehow.

;;; Code:

(defvar xterm-mouse-debug-buffer nil)

(defvar xterm-mouse-last)

;; Mouse events symbols must have an 'event-kind property with
;; the value 'mouse-click.
(dolist (event-type '(mouse-1 mouse-2 mouse-3
			      M-down-mouse-1 M-down-mouse-2 M-down-mouse-3))
  (put event-type 'event-kind 'mouse-click))

(defun xterm-mouse-translate (event)
  "Convert XTerm mouse event to Emacs mouse event."
  ;; From the xterm control sequence spec:
  ;;
  ;; Parameters (such as pointer position and button number) for all
  ;; mouse tracking escape sequences generated by xterm encode numeric
  ;; parameters in a single character as value+32. For example, !
  ;; specifies the value 1. The upper left character position on the
  ;; terminal is denoted as 1,1.
  (let* ((type (- (read-char) #o40))
	 (x (- (read-char) #o40 1))
	 (y (- (read-char) #o40 1))
	 (posn (xterm-mouse-posn x y))
	 (event (xterm-mouse-event type posn "")))
    (set-terminal-parameter nil 'xterm-mouse-x x)
    (set-terminal-parameter nil 'xterm-mouse-y y)
    (vector (setq last-input-event event))
    )
  )

;; These two variables have been converted to terminal parameters.
;;
;;(defvar xterm-mouse-x 0
;;  "Position of last xterm mouse event relative to the frame.")
;;
;;(defvar xterm-mouse-y 0
;;  "Position of last xterm mouse event relative to the frame.")

(defvar xt-mouse-epoch nil)

;; Indicator for the xterm-mouse mode.

(defun xterm-mouse-position-function (pos)
  "Bound to `mouse-position-function' in XTerm mouse mode."
  (when (terminal-parameter nil 'xterm-mouse-x)
    (setcdr pos (cons (terminal-parameter nil 'xterm-mouse-x)
		      (terminal-parameter nil 'xterm-mouse-y))))
  pos)

(defun xterm-mouse-truncate-wrap (f)
  "Truncate with wrap-around."
  (condition-case nil
      ;; First try the built-in truncate, in case there's no overflow.
      (truncate f)
    ;; In case of overflow, do wraparound by hand.
    (range-error
     ;; In our case, we wrap around every 3 days or so, so if we assume
     ;; a maximum of 65536 wraparounds, we're safe for a couple years.
     ;; Using a power of 2 makes rounding errors less likely.
     (let* ((maxwrap (* 65536 2048))
            (dbig (truncate (/ f maxwrap)))
            (fdiff (- f (* 1.0 maxwrap dbig))))
       (+ (truncate fdiff) (* maxwrap dbig))))))

(defun xterm-mouse-event (pb posn modifiers)
  ;; From the xterm control sequence spec:
  ;;
  ;; The low two bits of Pb encode button information: 0=MB1 pressed,
  ;; 1=MB2 pressed, 2=MB3 pressed, 3=release. The next three bits
  ;; encode the modifiers which were down when the button was pressed
  ;; and are added together: 4=Shift, 8=Meta, 16=Control. Note however
  ;; that the shift and control bits are normally unavailable.
  ;;
  ;; On button-motion events, xterm adds 32 to the [Pb] event
  ;; code. The other bits of the event code specify button and
  ;; modifier keys as in normal mode.
  ;;
  ;; Wheel mice may return buttons 4 and 5 [which] are represented by
  ;; the same event codes as buttons 1 and 2 respectively, except that
  ;; 64 is added to the event code. Release [and movement] events for
  ;; the wheel buttons are not reported.
  (let* ((event 
	  (cond
	   ((memq pb '(0 1 2)); down-mouse-{1,2,3}
	    (xterm-mouse-down (+ pb 1) posn))
	   ((= pb 3); {click,drag}-mouse-{1,2,3}
	    (xterm-mouse-up posn))
	   ((memq pb '(32 33 34)); mouse-movement
	    (list 'mouse 'movement posn)); cheat: supply 'movement instead of a button
	   ((memq pb '(64 65)); mouse-{4,5}
	    (xterm-mouse-click (- pb 60) posn))
	   ((> (logand pb 4) 0); S-
	    (xterm-mouse-event (- pb 4) posn (format "S-%s" modifiers)))
	   ((> (logand pb 8) 0); M-
	    (xterm-mouse-event (- pb 8) posn (format "M-%s" modifiers)))
	   ((> (logand pb 16) 0); C-
	    (xterm-mouse-event (- pb 16) posn (format "C-%s" modifiers)))
	   (t
	    (error "Unrecognized mouse event type: %d" pb))
	   ))
	 (type (pop event))
	 (button (pop event))
	 (event-type (intern (format "%s%s-%S" modifiers type button))))
    (cons event-type event)
    )
  )

(defun xterm-mouse-posn (x y)
  (let* ((w (window-at x y))
	 (ltrb (window-edges w))
	 (left (pop ltrb))
	 (top (pop ltrb))
	 (posn (if w
		   (posn-at-x-y (- x left) (- y top) w t)
		 (append (list nil 'menu-bar)
			 (nthcdr 2 (posn-at-x-y x y))))))
    (setcar (nthcdr 3 posn) (xterm-mouse-truncate-wrap
			     (* 1000
				(- (float-time)
				   (or xt-mouse-epoch
				       (setq xt-mouse-epoch (float-time)))))))
    posn
    )
  )

(defvar xterm-buttons-down (make-vector 4 nil)
  "Tracks buttons which are currently down.

Slots 1-3 hold the down-event of the respective mouse button, if
it is down; slot 0 holds a LIFO list of the same events (since
xterm doesn't tell us *which* button goes up on a release)" )

(defun xterm-mouse-down (button posn)
  (let* ((down-list (aref xterm-buttons-down 0))
	 (old-down-event (aref xterm-buttons-down button))
	 (id (list button (posn-x-y posn)))
	 (new-down-event (list id posn)))
    (when old-down-event
      (message "Oops... button %d pressed twice with no intervening release" button)
      (setq down-list (delq old-down-event down-list)))
    ;; not sure why mouse.el doesn't do this...
    (deactivate-mark)
    (push new-down-event down-list)
    (aset xterm-buttons-down 0 down-list)
    (aset xterm-buttons-down button new-down-event)
    (list 'down-mouse button posn 1)
    )
  )

(defun xterm-mouse-up (up-posn)
  (let* ((down-list (aref xterm-buttons-down 0))
	 (down (pop down-list))
	 (down-id (pop down))
	 (down-posn (car down))
	 (button (car down-id))
	 (up-id (list button (posn-x-y posn))))
    (aset xterm-buttons-down 0 down-list)
    (aset xterm-buttons-down button nil)
    (if (equal down-id up-id)
	(xterm-mouse-click button up-posn)
      (list 'drag-mouse button down-posn posn))
    )
  )

(defun xterm-mouse-click (button posn)
  (list 'mouse button posn 1))

;;;###autoload
(define-minor-mode xterm-mouse-mode
  "Toggle XTerm mouse mode.
With prefix arg, turn XTerm mouse mode on if arg is positive, otherwise turn
it off.

Turn it on to use Emacs mouse commands, and off to use xterm mouse commands.
This works in terminal emulators compatible with xterm.  It only
works for simple uses of the mouse.  Basically, only non-modified
single clicks are supported.  When turned on, the normal xterm
mouse functionality for such clicks is still available by holding
down the SHIFT key while pressing the mouse button."
  :global t :group 'mouse
  (let ((do-hook (if xterm-mouse-mode 'add-hook 'remove-hook)))
    (funcall do-hook 'terminal-init-xterm-hook
             'turn-on-xterm-mouse-tracking-on-terminal)
    (funcall do-hook 'delete-terminal-functions
             'turn-off-xterm-mouse-tracking-on-terminal)
    (funcall do-hook 'suspend-tty-functions
             'turn-off-xterm-mouse-tracking-on-terminal)
    (funcall do-hook 'resume-tty-functions
             'turn-on-xterm-mouse-tracking-on-terminal)
    (funcall do-hook 'suspend-hook 'turn-off-xterm-mouse-tracking)
    (funcall do-hook 'suspend-resume-hook 'turn-on-xterm-mouse-tracking)
    (funcall do-hook 'kill-emacs-hook 'turn-off-xterm-mouse-tracking))
  (if xterm-mouse-mode
      ;; Turn it on
      (progn
	(unless (boundp 'xterm-mouse-handler-needs-read-key)
	  (xterm-patch-mouse-handlers))
	(setq mouse-position-function #'xterm-mouse-position-function)
	(turn-on-xterm-mouse-tracking))
    ;; Turn it off
    (turn-off-xterm-mouse-tracking 'force)
    (setq mouse-position-function nil)))

(defun xterm-patch-mouse-handlers ()
  "Patch mouse event handlers to call `read-key' instead of
`read-event'. Otherwise, those handlers will intercept xterm's
escape sequences before they can be converted into mouse events."
  
  (defvar xterm-mouse-handler-needs-read-key nil
    "Set non-nil by advised mouse event handlers, which need to call
`read-key' instead of `read-event' whenever `xterm-mouse-mode' is active" )
  
  (defadvice read-event (around change-read-event-to-read-key activate compile)
    "Calling this function while `xterm-mouse-handler-needs-read-key'
is non-nil executes `read-key' instead"
    
    (if xterm-mouse-handler-needs-read-key
	(setq ad-return-value (read-key))
      ad-do-it)
    )
  
  (dolist (f '(mouse-drag-mode-line-1 mouse-drag-vertical-line
				      mouse-drag-region mouse-drag-track
				      mouse-show-mark mouse-drag-secondary
				      widget-button-click))
    ;; have to build this definition manually because defadvice is a
    ;; macro and doesn't evaluate 'f' properly otherwise.
    (funcall (list 'lambda nil
		   (list 'defadvice f
			 '(around change-read-event-to-read-key activate compile)
			 "Set `xterm-mouse-handler-needs-read-key' during this function call."
			 '(setq xterm-mouse-handler-needs-read-key t
				ad-return-value ad-do-it
				xterm-mouse-handler-needs-read-key nil))))
    )
  )

(defun turn-on-xterm-mouse-tracking ()
  "Enable Emacs mouse tracking in xterm."
  (dolist (terminal (terminal-list))
    (turn-on-xterm-mouse-tracking-on-terminal terminal)))

(defun turn-off-xterm-mouse-tracking (&optional force)
  "Disable Emacs mouse tracking in xterm."
  (dolist (terminal (terminal-list))
    (turn-off-xterm-mouse-tracking-on-terminal terminal)))

(defun turn-on-xterm-mouse-tracking-on-terminal (&optional terminal)
  "Enable xterm mouse tracking on TERMINAL."
  (when (and xterm-mouse-mode (eq t (terminal-live-p terminal))
	     ;; Avoid the initial terminal which is not a termcap device.
	     ;; FIXME: is there more elegant way to detect the initial terminal?
	     (not (string= (terminal-name terminal) "initial_terminal")))
    (unless (terminal-parameter terminal 'xterm-mouse-mode)
      ;; Simulate selecting a terminal by selecting one of its frames ;-(
      (with-selected-frame (car (frames-on-display-list terminal))
        (define-key input-decode-map "\e[M" 'xterm-mouse-translate))
      (set-terminal-parameter terminal 'xterm-mouse-mode t))
    (send-string-to-terminal "\e[?1002h" terminal)))

(defun turn-off-xterm-mouse-tracking-on-terminal (terminal)
  "Disable xterm mouse tracking on TERMINAL."
  ;; Only send the disable command to those terminals to which we've already
  ;; sent the enable command.
  (when (and (terminal-parameter terminal 'xterm-mouse-mode)
             (eq t (terminal-live-p terminal))
	     ;; Avoid the initial terminal which is not a termcap device.
	     ;; FIXME: is there more elegant way to detect the initial terminal?
	     (not (string= (terminal-name terminal) "initial_terminal")))
    ;; We could remove the key-binding and unset the `xterm-mouse-mode'
    ;; terminal parameter, but it seems less harmful to send this escape
    ;; command too many times (or to catch an unintended key sequence), than
    ;; to send it too few times (or to fail to let xterm-mouse events
    ;; pass by untranslated).
    (send-string-to-terminal "\e[?1002l" terminal)))

(provide 'ext-mouse)

;; arch-tag: 84962d4e-fae9-4c13-a9d7-ef4925a4ac03
;;; xt-mouse.el ends here
